perm filename PLTMAN.F4[P,LCS] blob
sn#251275 filedate 1976-12-07 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE PLTMAN
C00010 ENDMK
Cā;
SUBROUTINE PLTMAN
COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,IROT,RLR,RUD,CONST,E
1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
COMMON/CLR/KP,KQ,KR,KS,P
EQUIVALENCE(LIST,CURV)
DIMENSION CURV(2,3000),HIST(0/63),DIF(3)
COMMON /EDGEC/ A0,A1,A2,A3,A4,A5,A6,A7,
1 DEBUG,TE(1),XP(1),YP(1),PARMAX,
1 HALF,FILE,RR,COH,RX,RY,CL,SL,D,B,FOUND
COMMON /LISTC/LIST(6,1000),LIST5(0/1000),NEWEND,LO
COMMON/COMMAC/BCLIP,TCLIP,BITS,IWID,LINLEN,FLINE,LLINE,
1 LSIDE,RSIDE,DTA,HYSTAB(1)
COMMON/FU/FUJ(512),JJX,RDIV,ADML /OUTF/IOUT,IXGP
INTEGER FI,FILEN,EWE,HIST,BITS,
1 XIX,XI,FLINE,RSIDE,
1 NUM2,NUM3,IDD,PL,LIST5,X
REAL LIST,RR,CL,SL,LEAP,LEA6,LEA3,CONST,FRAC,
1 RX,RY,TEXT,TH,W1,W2,B1,B2,V1,V2,
1 LV,LW,LB,D1,D2,CURV,T,X1,X2,A1,A2,C1,C2,MA,LC,
1 D,B,DIF,B0,BB1,C3,C4
DATA JJX/2/
DIF(1)=0.0
B0=0.0
BB1=2**BITS-1
IXYZ=0
CONST=2.41
IF(FLINE.EQ.0.AND.LSIDE.EQ.0.AND.
1 LLINE.EQ.252.AND.RSIDE.EQ.251) CONST=CONST*.6667
68 LEAP=(RR/2.+CONST)*RTO
LEA6=LEAP/6.
LEA3=LEAP/3.
TH=(LEAP**2)*0.075
DO 70 IDD=0,63
70 HIST(IDD)=0
FRAC=64.0/FLOAT(2**BITS)
DO 100 XIX=1,NEWEND
IDD=IFIX(LIST(5,XIX)*FRAC+0.5)
IF(0.GT.IDD) IDD=0
IF(63.LT.IDD) IDD=63
HIST(IDD)=HIST(IDD)+1
100 CONTINUE
DO 110 IDD=1,63
110 HIST(IDD)=HIST(IDD)+HIST(IDD-1)
IF(HIST(63).NE.NEWEND) PAUSE 'ERROR IN PLOU'
NUM2=IFIX(FLOAT(NEWEND)/3.+0.5)
NUM3=IFIX(FLOAT(NEWEND)*2./3.+0.5)
DO 121 IDD=1,63
IF(NUM2.GE.(HIST(IDD)+HIST(IDD-1))/2) DIF(2)=FLOAT(
1 IDD)/FRAC
121 IF(NUM3.GE.(HIST(IDD)+HIST(IDD-1))/2) DIF(3)=FLOAT(
1 IDD)/FRAC
DO 123 I=0,1000
123 LIST5(I)=1
125 XI=1
DO 120 XIX=1,NEWEND
D=LIST(5,XIX)
B=LIST(6,XIX)
IF(((B+D.LT.B0+DIF(1)).OR.(B.GT.BB1-DIF(1)
1 )).OR.(D.LT.DIF(1))) GOTO 120
RX=LIST(1,XIX)*RTO
RY=LIST(2,XIX)*RTO
CL=LIST(3,XIX)*LEA6
SL=LIST(4,XIX)*LEA6
CURV(1,XI)=RX-SL
CURV(2,XI)=RY+CL
CURV(3,XI)=RX+SL
CURV(4,XI)=RY-CL
IF(((B+D.LT.B0+DIF(2)).OR.(B.GT.BB1-DIF(2)
1 )).OR.(D.LT.DIF(2))) GOTO 118
LIST5((XI-1)/2)=2
IF(((B+D.LT.B0+DIF(3)).OR.(B.GT.BB1-DIF(3)
1 )).OR.(D.LT.DIF(3))) GOTO 118
LIST5((XI-1)/2)=3
118 XI=XI+2
120 CONTINUE
DO 400 PL=1,3
GOTO(140,130,130),PL
130 X=1
DO 136 XI=1,EWE-3,2
I=(XI-1)/2
IF(LIST5(I).LT.PL) GOTO 136
C1=CURV(1,XI)
C2=CURV(2,XI)
C3=CURV(3,XI)
C4=CURV(4,XI)
CURV(1,X)=C1
CURV(2,X)=C2
CURV(3,X)=C3
CURV(4,X)=C4
LIST5((X-1)/2)=LIST5(I)
X=X+2
136 CONTINUE
XI=X
140 EWE=XI+1
FI=1
LA=0
DO 135 XIX=4,EWE,2
LI=XIX-2
IF((2.*CURV(1,LI)-CURV(1,XIX-3)-2.*CURV(1,XIX-1)+
1 CURV(1,XIX))**2+(2.*CURV(2,LI)-CURV(2,XIX-3)-
1 2.*CURV(2,XIX-1)+CURV(2,XIX))**2.LT.TH) GOTO 135
LA=LI
KI=FI+1
IF(KI.EQ.LA) GOTO 200
IF(PL.GT.1) GOTO 200
CURV(1,FI)=CURV(1,FI)*1.5-CURV(1,KI)*0.5
CURV(2,FI)=CURV(2,FI)*1.5-CURV(2,KI)*0.5
CURV(1,LA)=CURV(1,LA)*1.5-CURV(1,LA-1)*0.5
CURV(2,LA)=CURV(2,LA)*1.5-CURV(2,LA-1)*0.5
200 JA=RLR*(CURV(1,FI)-36.)+.5
JB=RUD*(CURV(2,FI)-120.)+.5
CC IF(IABS(JA-JAR).LT.4.AND.IABS(JB-JBR).LT.4)JCNT=JCNT+1
JA=JA/JPL
JB=JB/JPL
CALL LINES(3)
2002 NI=LA-2
JI=FI-1
DO 210 I=JI,NI
KI=I+1
LI=KI+1
MI=LI+1
B1=CURV(1,LI)-CURV(1,KI)
B2=CURV(2,LI)-CURV(2,KI)
IF (I.EQ.JI) GOTO 202
A1=CURV(1,KI)-CURV(1,I)
A2=CURV(2,KI)-CURV(2,I)
GOTO 204
202 A1=B1
A2=B2
204 IF (I.EQ.NI) GOTO 206
C1=CURV(1,MI)-CURV(1,LI)
C2=CURV(2,MI)-CURV(2,LI)
GOTO 208
206 C1=B1
C2=B2
208 MA=A1**2+A2**2
LB=B1**2+B2**2
LC=C1**2+C2**2
V1=A1*LB+B1*MA
V2=A2*LB+B2*MA
W1=B1*LC+C1*LB
W2=B2*LC+C2*LB
LV=SQRT(V1**2+V2**2)
LW=SQRT(W1**2+W2**2)
LB=SQRT(LB)
CC IF (LV.LT.1.E-6.OR.LW.LT.1.E-6) PAUSE 'LV LW'
AA=LB*.5858
AB=AA/LW
AA=AA/LV
V1=V1*AA
V2=V2*AA
W1=W1*AB
W2=W2*AB
D1=B1-V1-W1
D2=B2-V2-W2
DO 220 K=1,8
T=FLOAT(K)/8.
T1=2.-T
T2=3.-2.*T
IX1=RLR*(CURV(1,KI)-36.+(V1*T1+(W1+D1*T2)*T)*T+.5)
IX2=RUD*(CURV(2,KI)-120.+(V2*T1+(W2+D2*T2)*T)*T+.5)
NA=2
JA=IX1/JPL
JB=IX2/JPL
IF(P)GO TO 421
IF(JA.GE.KP.AND.JA.LE.KQ.AND.JB.GE.KR.AND.JB.
1 LE.KS)NA=3
421 IF(A)GO TO 221
IF(JA.GE.KA.AND.JA.LE.KB.AND.JB.GE.KC.AND.JB.
1 LE.KD)NA=3
221 IF(E)GO TO 220
IF(JA.LE.IA.OR.JA.GE.IB.OR.JB.LE.IC.OR.JB.GE.ID)NA=3
C LEAVES CLEAR AREA
220 IF(PLT)CALL LINES(NA)
IF(PLT)GO TO 210
2222 IF(IXYZ)GO TO 211
CALL LINES(NA)
211 IXYZ=IXYZ-1
IF(IXYZ.EQ.-3)IXYZ=0
C DPY EVERY 5TH TIME.
210 CONTINUE
IF(PLT.NE.0)GO TO 135
CPP IF(MOD(XIX,8).EQ.0)CALL DPYOUT(1)
135 FI=LA+1
CPP IF(PLT.EQ.0)CALL DPYOUT(1)
GOTO(300,300,500),PL
300 IF(PLT.EQ.0)CALL DPYOUT(1)
TYPE 301
ACCEPT 1001,WHICH
IF(WHICH.EQ.'E'.OR.WHICH.EQ.'X')GO TO 500
IF(WHICH.EQ.'R')GO TO 500
C R=GO BACK FOR CHANGE BEFORE FINAL END.
301 FORMAT(' CHANGE THE PEN OR R(ETURN)',$)
IF(PLT.EQ.0)GO TO 400
JX=JX+JJX+IXGP
JY=JY+JJX+IXGP
C MOVES PEN JJX NOTCHES EACH TIME AROUND. (2 FOR CALCOMP, 1 FOR XGP)
400 CONTINUE
500 IF(PLT)CALL PLOT(0,0,3)
IF(PLT.EQ.0)CALL DPYOUT(1)
RETURN
1001 FORMAT(A1)
END